home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / Advanced M247288152001.psc / divers.bas < prev    next >
Encoding:
BASIC Source File  |  2000-02-03  |  8.6 KB  |  291 lines
  1. Attribute VB_Name = "divers"
  2. ' this module containes general functions
  3.  
  4. Option Explicit
  5. Public OK As Boolean
  6. Public Cancel As Boolean
  7. Public CurHTMLfile As String
  8.  
  9. ' API
  10. Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
  11. Public Const SWP_NOMOVE = &H2
  12. Public Const SWP_NOSIZE = &H1
  13. Public Const HWND_NOTOPMOST = -2
  14. Public Const HWND_TOPMOST = -1
  15.  
  16. Public Const GMEM_MOVEABLE = &H2
  17. Public Const GMEM_ZEROINIT = &H40
  18. Public Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)
  19.  
  20. Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
  21. Public Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
  22.  
  23.  
  24. Public Sub BevelPic(pic As PictureBox, _
  25.                      ByVal X1 As Long, ByVal Y1 As Long, _
  26.                      ByVal X2 As Long, ByVal Y2 As Long, _
  27.                      ByVal inset As Boolean)
  28.    Dim above As Long, under As Long
  29.    
  30.    If inset = False Then
  31.       above = vb3DHighlight
  32.       under = vbButtonShadow
  33.       Else
  34.       above = vbButtonShadow
  35.       under = vb3DHighlight
  36.       End If
  37.    X2 = X2 - 1
  38.    Y2 = Y2 - 1
  39.    pic.Line (X1, Y1)-(X2, Y2), vb3DDKShadow, B
  40.    X1 = X1 + 1
  41.    Y1 = Y1 + 1
  42.    X2 = X2 - 1
  43.    Y2 = Y2 - 1
  44.    pic.Line (X1, Y1)-(X2, Y1), above
  45.    pic.Line (X1, Y1)-(X1, Y2), above
  46.    pic.Line (X2, Y1)-(X2, Y2), under
  47.    pic.Line (X1, Y2)-(X2, Y2), under
  48.    
  49. End Sub
  50.  
  51. ' returns a binary string of a byte
  52. Public Function BinStr(ByVal B As Byte) As String
  53.    Dim I As Long, txt As String
  54.    For I = 0 To 7
  55.       txt = txt & IIf((B And (2 ^ (7 - I))) = 0, "0", "1")
  56.    Next I
  57.    BinStr = txt
  58. End Function
  59.  
  60. ' returns the value of a binary string
  61. Public Function BinValue(ByVal BinStr As String) As Variant
  62.    Dim v As Variant
  63.    Dim I As Long, L As Long
  64.    L = Len(BinStr)
  65.    For I = 1 To L
  66.       v = v + 2 ^ (L - I) * Val(Mid(BinStr, I, 1))
  67.    Next I
  68.    BinValue = v
  69. End Function
  70.  
  71. ' Hourglass mousepointer is not visible above a browser window
  72. ' this routine makes busy-ness visible
  73. Public Sub Busy(frm As Form, truefalse As Boolean)
  74.    Static BackColor As Long
  75.    If truefalse = True Then
  76.       Screen.MousePointer = vbHourglass
  77.       BackColor = frm.BackColor
  78.       frm.BackColor = RGB(255, 0, 0)
  79.       Else
  80.       Screen.MousePointer = vbDefault
  81.       frm.BackColor = BackColor
  82.       End If
  83. End Sub
  84. Public Function Convert(ByVal Value As Single, _
  85.                         ByVal FromMin As Single, ByVal FromMax As Single, _
  86.                         ByVal ToMin As Single, ByVal ToMax As Single) As Single
  87.       
  88.    Dim F As Single, ToAdd As Long
  89.    If (ToMax - ToMin) = (FromMax - FromMin) Then
  90.       F = 1
  91.       Else
  92.       If ToMin < 0 Then ToAdd = 1 Else ToAdd = 0
  93.       F = (ToMax - ToMin) / (FromMax - FromMin + ToAdd)
  94.       End If
  95.    
  96.    Convert = ToMin + (Value - FromMin) * F
  97. End Function
  98.  
  99.  
  100. ' transforms a txt file into a html file
  101. ' isn't realy necessary here
  102. Public Function File2html(ByVal File As String, ByVal Title As String) As String
  103.    Dim ch As Long, I As Long
  104.    Dim Regel As String
  105.    Dim txt As String
  106.    Dim ipb As String
  107.    Dim Kolom() As Variant, KolomH() As Variant, k As Long, aK As Long
  108.    Dim tW As Long
  109.    
  110.    txt = txt & GetHeader(File, Title)
  111.    txt = txt & "    " & File & vbCrLf
  112.    ch = FreeFile
  113.    Open File For Input As ch
  114.    Line Input #ch, Regel
  115.    txt = txt & "    <PRE>" & vbCrLf
  116.    txt = txt & "    " & Regel & vbCrLf
  117.    While Not EOF(ch)
  118.       Line Input #ch, Regel
  119.       txt = txt & "    " & Regel & vbCrLf
  120.    Wend
  121.    txt = txt & "    </PRE>" & vbCrLf
  122.  
  123.    Close ch
  124.    txt = txt & GetFooter()
  125.  
  126.    File2html = txt
  127. End Function
  128.  
  129. ' sets a value to a fixed length string, right aligned
  130. ' used with proportional fonts
  131. Function FixStr(ByVal s As Variant, ByVal L As Long, ByVal F As String) As String
  132.    Dim txt As String
  133.    txt = CStr(s)
  134.    While Len(txt) < L
  135.      txt = Left(F, 1) & txt
  136.    Wend
  137.    FixStr = txt
  138. End Function
  139.  
  140. Public Function getBit(ByVal Value As Byte, ByVal BitNo As Long) As Long
  141.    getBit = IIf((Value And (2 ^ BitNo)) = 0, 0, 1)
  142. End Function
  143.  
  144.  
  145. ' chr(0) is not the end of the string, so generate your own
  146. ' string representation of the commandstring for displaying it
  147. Public Function getComStrStr(ByVal CommandStr As String) As String
  148.    Dim txt As String, k As String * 1
  149.    Dim I As Long
  150.    For I = 1 To Len(CommandStr)
  151.       k = Mid(CommandStr, I, 1)
  152.       If Asc(k) < 32 Then
  153.          txt = txt & Chr(128)
  154.          Else
  155.          txt = txt & k
  156.          End If
  157.    Next I
  158.    getComStrStr = txt
  159. End Function
  160.  
  161. ' decimal representation of the commandstring
  162. Public Function getComStrDec(ByVal CommandStr As String) As String
  163.    Dim txt As String
  164.    Dim I As Long
  165.    For I = 1 To Len(CommandStr)
  166.       txt = txt & Format(Asc(Mid(CommandStr, I, 1)), "000") & " "
  167.    Next I
  168.    getComStrDec = txt
  169. End Function
  170.  
  171.  
  172. ' hexadecimal representation of the commandstring
  173. Public Function getComStrHex(ByVal CommandStr As String) As String
  174.    Dim txt As String
  175.    Dim I As Long
  176.    For I = 1 To Len(CommandStr)
  177.       txt = txt & HexByte(Asc(Mid(CommandStr, I, 1))) & " "
  178.    Next I
  179.    getComStrHex = txt
  180. End Function
  181.  
  182. Public Function setBit(ByVal Value As Byte, ByVal BitNo As Long, ByVal OnOff As Boolean) As Byte
  183.    Value = Value Or (2 ^ BitNo)
  184.    If OnOff = False Then Value = Value Xor (2 ^ BitNo)
  185.    setBit = Value
  186. End Function
  187.  
  188. Public Function GetFileTitle(ByVal FullFilename As Variant) As Variant
  189.    Dim I As Integer
  190.    Dim nm As String
  191.    Dim k As String * 1
  192.    
  193.    For I = Len(FullFilename) To 1 Step -1
  194.      k = Mid(FullFilename, I, 1)
  195.      If k <> "\" Then nm = k + nm Else Exit For
  196.    Next I
  197.    GetFileTitle = nm
  198. End Function
  199.  
  200. ' makes a html footer
  201. Public Function GetFooter() As String
  202.    Dim txt As String
  203.    txt = txt & "  </BODY>" & vbCrLf
  204.    txt = txt & "</HTML>" & vbCrLf
  205.    GetFooter = txt
  206. End Function
  207.  
  208. ' makes a html header
  209. Public Function GetHeader(ByVal File As String, Optional ByVal Title As String) As String
  210.    Dim txt As String
  211.    
  212.    If Title = "" Then Title = GetFileTitle(File)
  213.    txt = "<!DOCTYPE HTML PUBLIC '-//W3C//DTD HTML 4.0 Transitional//EN'>" & vbCrLf
  214.    txt = txt & "<HTML>" & vbCrLf
  215.    txt = txt & "  <HEAD>" & vbCrLf
  216.    txt = txt & "    <TITLE>" & Title & "</TITLE>" & vbCrLf
  217.    txt = txt & "    <STYLE TYPE='text/css'>" & vbCrLf
  218.    txt = txt & "        PRE   {font-size:8pt;}" & vbCrLf
  219.    txt = txt & "        #red    {color:red;}" & vbCrLf
  220.    txt = txt & "        #green   {color:green;}" & vbCrLf
  221.    txt = txt & "        BODY     {background-color:#E8E8E8;}" & vbCrLf
  222.    txt = txt & "    </STYLE>" & vbCrLf
  223.    txt = txt & "  </HEAD>" & vbCrLf
  224.    txt = txt & "  <BODY>" & vbCrLf
  225.    GetHeader = txt
  226. End Function
  227.  
  228. ' hex string of a byte, fixed to 2 digits
  229. Public Function HexByte(ByVal B As Byte) As String
  230.    Dim txt As String
  231.    txt = Hex(B)
  232.    If Len(txt) = 1 Then txt = "0" & txt
  233.    HexByte = txt
  234. End Function
  235.  
  236. ' duration in 1000/sec
  237. Public Sub Pauze(ByVal Duration As Long)
  238.    Dim MakePiano
  239.    MakePiano = Timer
  240.    While Timer - MakePiano < Duration / 1000: DoEvents: Wend
  241. End Sub
  242.  
  243. ' read Big Endian - variable length variabel
  244. ' ch=filehandle, pos=position in file
  245. Public Function readVarLen(ByVal ch As Long, Pos As Long) As Long
  246.    Dim Value As Long
  247.    Dim C As Byte
  248.  
  249.    Get #ch, Pos, C: Pos = Pos + 1
  250.    Value = C
  251.    If (Value And &H80) <> 0 Then
  252.        Value = Value And &H7F
  253.        Do
  254.          Value = Value * 128
  255.          Get #ch, Pos, C: Pos = Pos + 1
  256.          C = C And &H7F
  257.          Value = Value + C
  258.        Loop While (C And &H80) <> 0
  259.        End If
  260.    readVarLen = Value
  261. End Function
  262.  
  263. ' binary rotate Left
  264. Public Function RotateLByte(ByVal B As Byte) As Byte
  265.    RotateLByte = ((B * 2) Mod 256) + IIf((B And 128) = 0, 0, 1)
  266. End Function
  267.  
  268. ' binary rotate Right
  269. Public Function RotateRByte(ByVal B As Byte) As Byte
  270.    RotateRByte = (B \ 2) Or IIf((B And 1) = 0, 0, 128)
  271. End Function
  272.  
  273. ' write Big Endian - I don't use it! Can be removed
  274. Public Sub WriteVarLen(ByVal ch As Long, ByVal Value As Long)
  275.    Dim buffer As Long
  276.    buffer = Value And &H7F
  277.    While Value \ 128 > 0
  278.       Value = Value \ 128
  279.       buffer = buffer * 256
  280.       buffer = buffer Or ((Value And &H7F) Or &H80)
  281.    Wend
  282.    Do
  283.       Put #ch, , CByte(buffer And 255) ': Pos = Pos + 1
  284.       If (buffer And &H80) Then
  285.          buffer = buffer \ 256
  286.          Else
  287.          Exit Do
  288.          End If
  289.    Loop
  290. End Sub
  291.